home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / netmail / txtq130.zip / TXTQ.PAS < prev   
Pascal/Delphi Source File  |  1996-01-26  |  22KB  |  807 lines
  1. {$N-,E- no math support needed}
  2. {$X- function calls may not be discarded}
  3. {$I- disable I/O checking (trap errors by checking IOResult)}
  4.  
  5. UNIT TXTQ; (*** Common procedures for ROBOQ, SLMR and SRQ ***)
  6.  
  7. INTERFACE
  8.  
  9. USES
  10.   DOS,
  11.   Heapman;
  12.  
  13. CONST
  14.   MaxBytes = 61440; {60k}
  15.  
  16. TYPE
  17.   MsgArray = ARRAY [1..MaxBytes] OF CHAR;
  18.  
  19.   ConfRec = ^ConfDAT;
  20.   ConfDAT = RECORD
  21.               Num : WORD;
  22.               Name: STRING [15];
  23.               Next: ConfRec;
  24.             END;
  25.  
  26.   MsgRec = ^MsgPtr;
  27.   MsgPtr = RECORD
  28.              Conf : WORD;
  29.              Block: LONGINT;
  30.              Next : MsgRec;
  31.            END;
  32.  
  33. CONST
  34.   author = 'v1.30: January 26, 1996. (c) 1996 by David Daniel Anderson - Reign Ware.';
  35.   cursorState: BYTE = 1; {0..3}
  36.   cursorData: ARRAY [0..3] OF CHAR = (#179, #47, #196, #92);
  37.   lineNumb: LONGINT = 0;
  38.   DATname = 'MESSAGES.DAT';
  39.   CONname = 'CONTROL.DAT';
  40.  
  41. VAR
  42.   ConfList: ConfRec;
  43.   MsgList: MsgRec;
  44.   Conferences: WORD;
  45.   Blocks: LONGINT;
  46.   UserName: STRING [25];
  47.   BBSname,
  48.   BBSID: STRING;
  49.   StartDIR,
  50.   TXTQ_DIR: PATHSTR;
  51.  
  52. {===========================================================================}
  53.  
  54. PROCEDURE WriteErr (problem: BYTE);
  55. { PROCEDURE cursorOff; }
  56. PROCEDURE cursorOn;
  57. { FUNCTION WhereX: BYTE; }
  58. { FUNCTION WhereY: BYTE; }
  59. { PROCEDURE GotoXY (X, Y: BYTE); }
  60. { PROCEDURE WriteCharAtCursor (X: CHAR); }
  61. { PROCEDURE ClrEol; }
  62. FUNCTION IntToStr (vint: LONGINT): STRING;
  63. FUNCTION LeadingZero (w: WORD): STRING;
  64. PROCEDURE CheckIO;
  65. { FUNCTION IsFile (CONST filename: PATHSTR): BOOLEAN; }
  66. { FUNCTION IsDir (CONST filename: PATHSTR): BOOLEAN; }
  67. FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
  68. { PROCEDURE EraseFile (CONST CurrentFile: STRING); }
  69. { PROCEDURE EraseAllFiles; }
  70. PROCEDURE updateCursor;
  71. { PROCEDURE UpFast (VAR Str: STRING); }
  72. { FUNCTION UpStr (lstr : STRING): STRING; }
  73. FUNCTION RPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
  74. { FUNCTION LPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING; }
  75. FUNCTION RTrim (InStr: STRING): STRING;
  76. { FUNCTION LTrim (InStr: STRING): STRING; }
  77. FUNCTION Trim (InStr: STRING): STRING;
  78. FUNCTION StrToDoubleChar (conf: STRING): STRING;
  79. PROCEDURE ReadStr (VAR f : FILE; VAR s : STRING);
  80. { FUNCTION GetQWKname (Qname: PATHSTR; VAR Qext: EXTSTR): BOOLEAN; }
  81. PROCEDURE PrepareFiles (VAR TextName: PATHSTR; VAR TextExtension: EXTSTR; VAR TextFile: FILE; VAR MsgDAT: FILE);
  82. PROCEDURE AddConfToList (CONST ConfNumStr, ConfName: STRING);
  83. PROCEDURE AddMsgToList (CONST ConfNumStr: STRING; BlockNum: LONGINT);
  84. PROCEDURE Verify (CONST control, variable: STRING; OFFSET: BYTE);
  85. FUNCTION AddToArray (VAR Message: MsgArray; OFFSET: WORD; Line: STRING): WORD;
  86. FUNCTION FigureMSGsize (bytes: WORD; VAR chunks: WORD): STRING;
  87. PROCEDURE InitConfig (VAR Compressor: PATHSTR);
  88. { FUNCTION GetDateTime: STRING; }
  89. { PROCEDURE GetBBSID; }
  90. { PROCEDURE WriteControlDAT (CONST CONname: STRING); }
  91. FUNCTION CompressDAT (CONST QWKfile: STRING; CONST Compressor: PATHSTR): BOOLEAN;
  92. { FUNCTION WipeDir: BOOLEAN; }
  93. PROCEDURE Cleanup;
  94.  
  95. {===========================================================================}
  96.  
  97. IMPLEMENTATION
  98.  
  99. PROCEDURE WriteErr (problem: BYTE);
  100. VAR
  101.   message: STRING;
  102. BEGIN
  103.   IF problem > 0 THEN BEGIN
  104.     CASE problem OF
  105.       1: message := 'Command line error: no files matching specification found to process.';
  106.       2: message := 'A ' + DATname+ ' file already exists. MOVE, REName or DELete it.';
  107.       3: message := 'Can''t create a unique *.Q?? file. MOVE, REName or DELete some files.';
  108.       4: message := 'Invalid header portion encountered just above line number: ' + IntToStr (lineNumb) + ' - fix file!';
  109.       5: message := 'Error archiving ' + DATname+ ' - try archiving it manually.';
  110. {     6: message := '';  }
  111.       7: message := 'Unexpected file or directory error, unable to continue.';
  112.       ELSE message := 'Unknown error.';
  113.     END;
  114.     WriteLn (#7, 'Error encountered, number ', problem, ':'); WriteLn (message);
  115.   END;
  116. END;
  117.  
  118. PROCEDURE cursorOff; ASSEMBLER;
  119. (* Routine from SWAG *)
  120. ASM
  121.   mov AH, 3; mov BH, 0; Int $10; OR CH, $20; mov AH, 1; Int $10;
  122. END;
  123.  
  124. PROCEDURE cursorOn; ASSEMBLER;
  125. (* Routine from SWAG *)
  126. ASM
  127.   mov AH, 3; mov BH, 0; Int $10; AND CH, NOT $20; mov AH, 1; Int $10;
  128. END;
  129.  
  130. FUNCTION WhereX: BYTE; ASSEMBLER;
  131. (* Routine from SWAG *)
  132. ASM
  133.   MOV AH, 3     {Ask For current cursor position}
  134.   MOV BH, 0     { On page 0 }
  135.   Int 10h       { Return inFormation in DX }
  136.   Inc DL        { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
  137.   MOV AL, DL    { Return X position in AL For use in Byte Result }
  138. END;
  139.  
  140. FUNCTION WhereY: BYTE; ASSEMBLER;
  141. (* Routine from SWAG *)
  142. ASM
  143.   MOV AH, 3    {Ask For current cursor position}
  144.   MOV BH, 0    { On page 0 }
  145.   Int 10h      { Return inFormation in DX }
  146.   Inc DH       { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
  147.   MOV AL, DH   { Return Y position in AL For use in Byte Result }
  148. END;
  149.  
  150. PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER;
  151. (* Routine from SWAG *)
  152. ASM
  153.   MOV DH, Y    { DH = Row (Y) }
  154.   MOV DL, X    { DL = Column (X) }
  155.   Dec DH       { Adjust For Zero-based Bios routines }
  156.   Dec DL       { Turbo Crt.GotoXY is 1-based }
  157.   MOV BH, 0    { Display page 0 }
  158.   MOV AH, 2    { Call For SET CURSOR POSITION }
  159.   Int 10h
  160. END;
  161.  
  162. PROCEDURE WriteCharAtCursor (X: CHAR);
  163. (* Routine from SWAG *)
  164. VAR
  165.   reg: REGISTERS;
  166. BEGIN
  167.   reg. AH := $0A;
  168.   reg. AL := Ord (X);
  169.   reg. BH := $00;    {* Display Page Number. * for Graphics Modes! *}
  170.   reg. CX := 1;      {* Word for number of characters to write *}
  171.   Intr ($10, reg);
  172. END;
  173.  
  174. PROCEDURE ClrEol;
  175. (* Routine by DDA *)
  176. VAR
  177.   NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
  178.   X, Y, DistanceToRight: BYTE;
  179. BEGIN
  180.   X := WhereX;
  181.   Y := WhereY;
  182.   DistanceToRight := NumCol - X;
  183.   Write ('': DistanceToRight);
  184.   WriteCharAtCursor (#32);
  185.   GotoXY (X, Y);
  186. END;
  187.  
  188. FUNCTION IntToStr (vint: LONGINT): STRING;
  189. VAR
  190.   s: STRING;
  191. BEGIN
  192.   Str (vint, s);
  193.   IntToStr := s;
  194. END;
  195.  
  196. FUNCTION LeadingZero (w : WORD) : STRING;
  197. VAR
  198.   s : STRING;
  199. BEGIN
  200.   Str (w: 0, s);
  201.   IF Length (s) = 1 THEN
  202.     s := '0' + s;
  203.   LeadingZero := s;
  204. END;
  205.  
  206. PROCEDURE CheckIO;
  207. BEGIN
  208.   IF IOResult <> 0 THEN Halt (7);
  209. END;
  210.  
  211. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  212. VAR
  213.   Attr  : WORD;
  214.   cFile : FILE;
  215. BEGIN
  216.   Assign (cFile, FileName);
  217.   GetFAttr (cFile, Attr);
  218.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  219.     THEN IsDir := TRUE
  220.     ELSE IsDir := FALSE;
  221. END;
  222.  
  223. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  224. VAR
  225.   Attr  : WORD;
  226.   cFile : FILE;
  227. BEGIN
  228.   Assign (cFile, FileName);
  229.   GetFAttr (cFile, Attr);
  230.   IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
  231.     THEN IsFile := TRUE
  232.     ELSE IsFile := FALSE;
  233. END;
  234.  
  235. FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
  236. VAR
  237.   dirinfo   : SEARCHREC;
  238.   jPath     : PATHSTR;  { file path,       }
  239.   jDir      : DIRSTR;   {      directory,  }
  240.   jName     : NAMESTR;  {      name,       }
  241.   jExt      : EXTSTR;   {      extension.  }
  242. BEGIN
  243.   jPath := PStr;
  244.   IF jPath = '' THEN jPath := '*.*';
  245.   IF (NOT (jPath[Length(jPath)] in [':','\'])) AND IsDir (jPath) THEN
  246.     jPath:=jPath+'\';
  247.   IF (jPath[Length(jPath)] in [':','\']) THEN
  248.     jPath:=jPath+'*.*';
  249.  
  250.   FSplit (FExpand (jPath), jDir, jName, jExt);
  251.   jPath := jDir+jName+jExt;
  252.  
  253.   sDir := jDir;
  254.   GetFilePath := jPath;
  255. END;
  256.  
  257. PROCEDURE EraseFile (CONST FileName : STRING);
  258. VAR
  259.   cFile : FILE;
  260. BEGIN
  261.   IF IsFile (FileName) THEN BEGIN
  262.     Assign (cFile, FileName);
  263.     SetFAttr (cFile, 0);
  264.     Erase (cFile); CheckIO;
  265.   END;
  266. END;
  267.  
  268. PROCEDURE EraseAllFiles;
  269. VAR
  270.   JustFiles: WORD;
  271.   DirInfo : SEARCHREC;
  272. BEGIN
  273.   JustFiles := ReadOnly + Hidden + SysFile + Archive;
  274.   FindFirst ('*.*', JustFiles, DirInfo);
  275.   WHILE DosError = 0 DO
  276.   BEGIN
  277.     EraseFile (DirInfo. Name);
  278.     FindNext (DirInfo);
  279.   END;
  280. END;
  281.  
  282. PROCEDURE updateCursor;
  283. {code written by Sean Palmer, found in SWAG}
  284. BEGIN
  285.   cursorState := Succ (cursorState) AND 3;
  286.   Write (cursorData [cursorState], ^H);
  287. END;
  288.  
  289. PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  290. INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  291.         $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  292.  
  293. FUNCTION UpStr (lstr : STRING): STRING;
  294. BEGIN
  295.   upfast (lstr);
  296.   UpStr := lstr;
  297. END;
  298.  
  299. FUNCTION RPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
  300. BEGIN
  301.   WHILE (Length (bstr) < len) DO
  302.     bstr := bstr + pChar;
  303.   RPad := bstr;
  304. END;
  305.  
  306. FUNCTION LPad (bstr: STRING; len: BYTE; pChar: CHAR): STRING;
  307. BEGIN
  308.   WHILE (Length (bstr) < len) DO
  309.     bstr := pChar + bstr;
  310.   LPad := bstr;
  311. END;
  312.  
  313. FUNCTION RTrim (InStr: STRING): STRING;
  314. BEGIN
  315.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
  316.     Dec (InStr [0]);
  317.   RTrim := InStr;
  318. END;
  319.  
  320. FUNCTION LTrim (InStr: STRING): STRING;
  321. BEGIN
  322.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  323.     Delete (InStr, 1, 1);
  324.   LTrim := InStr;
  325. END;
  326.  
  327. FUNCTION Trim (InStr: STRING): STRING;
  328. BEGIN
  329.   Trim := RTrim (LTrim (InStr));
  330. END;
  331.  
  332. FUNCTION StrToDoubleChar (conf: STRING): STRING;
  333. VAR
  334.   i, VErr: INTEGER;
  335. BEGIN
  336.   Conf := Trim (conf);
  337.   Val (conf, i, VErr);
  338.   IF (VErr = 0)
  339.     THEN StrToDoubleChar := Chr (i MOD 256) + Chr (i DIV 256)
  340.     ELSE StrToDoubleChar := #0#0
  341. END;
  342.  
  343. PROCEDURE ReadStr (VAR f : FILE; VAR s : STRING);
  344. VAR
  345.   s1 : ARRAY [1..255] OF CHAR;
  346.   BytesRead : WORD;
  347.   crlf, p, i : INTEGER;
  348.   fp : LONGINT;
  349.  
  350. BEGIN
  351.   s := '';
  352.   crlf := 0;
  353.  
  354.   fp := FilePos (f);
  355.   BlockRead (f, s1, SizeOf (s1), BytesRead);
  356.   IF (BytesRead > 0) THEN  { if at EOF, go no further }
  357.   BEGIN
  358.     s [0] := Chr (BytesRead);
  359.     FOR i := 1 TO BytesRead DO
  360.       s [i] := s1 [i];
  361.     
  362.     p := Pos (#13#10, s);
  363.     IF (p > 0) THEN
  364.     BEGIN
  365.       s := Copy (s, 1, p - 1);
  366.       crlf := 2;
  367.     END;
  368.     Seek (f, fp + crlf + Length (s));
  369.   END;
  370. END;
  371.  
  372. FUNCTION GetQWKname (Qname: PATHSTR; VAR Qext: EXTSTR): BOOLEAN;
  373. VAR
  374.   letter3,
  375.   letter4: CHAR;
  376.   UniqueNameFound, NamesExhausted: BOOLEAN;
  377. BEGIN
  378.   UniqueNameFound := FALSE;
  379.   NamesExhausted := FALSE;
  380.  
  381.   letter3 := '0';
  382.   letter4 := '0';
  383.  
  384.   IF NOT IsFile (Qname+ '.QWK') THEN
  385.     Qext := '.QWK'
  386.   ELSE
  387.     WHILE (NOT UniqueNameFound) AND (NOT NamesExhausted) DO
  388.     BEGIN
  389.       Qext := '.Q' + letter3 + letter4;
  390.       IF NOT IsFile (Qname + Qext) THEN
  391.         UniqueNameFound := TRUE
  392.       ELSE { incremenent extension }
  393.         CASE letter4 OF
  394.           'Z': BEGIN
  395.                 letter4 := '0';
  396.                 CASE letter3 OF
  397.                   'Z': NamesExhausted := TRUE;
  398.                   '9': letter3 := 'A';
  399.                   ELSE Inc (letter3);
  400.                 END;
  401.                END;
  402.           '9': letter4 := 'A';
  403.           ELSE Inc (letter4);
  404.         END;
  405.     END;
  406.   GetQWKname := (NOT NamesExhausted)
  407. END;
  408.  
  409. PROCEDURE PrepareFiles (VAR TextName: PATHSTR; VAR TextExtension: EXTSTR;
  410. VAR TextFile: FILE; VAR MsgDAT: FILE);
  411. CONST
  412.   QmailLine: ARRAY [1..128] OF CHAR =
  413.   'Produced by Qmail...Copyright (c) 1995 by SparkWare.  All Rights' +
  414.   ' Reserved       Above for Compatibility with Qmail              ';
  415.  
  416. VAR
  417.   QWKname: PATHSTR;
  418.  
  419. BEGIN
  420.   IF IsFile (DATname) THEN Halt (2);
  421.  
  422.   IF NOT IsFile (TextName) THEN Halt (1);
  423.   Assign (TextFile, TextName);
  424.   Reset (TextFile, 1); CheckIO;
  425.  
  426.   QWKname := TextName;
  427.   IF (Pos ('.', QWKname) > 0) THEN
  428.     QWKname := Copy (QWKname, 1, Pos ('.', QWKname) - 1);
  429.   IF NOT GetQWKname (QWKname, TextExtension) THEN Halt (3);
  430.  
  431.   cursorOff;
  432.   Write ('Converting ', TextName, ' to ', DATname, ' please wait ... ');
  433.   TextName := QWKname;
  434.  
  435.   Assign (MsgDAT, DATname);
  436.   Rewrite (MsgDAT, 1); CheckIO;
  437.   BlockWrite (MsgDAT, QmailLine, 128); CheckIO;
  438. END;
  439.  
  440. PROCEDURE AddConfToList (CONST ConfNumStr, ConfName: STRING);
  441. (* Routine from SWAG *)
  442. { This Procedure will search through an ordered linked list,
  443. find out where the data belongs, and insert it into the list. }
  444.  
  445. VAR
  446.   Anchor, { Where we are in the list }
  447.   NewConf: ConfRec; { This is what we insert our data into. }
  448.   ConfNum: WORD;
  449.  
  450. BEGIN
  451.   ConfNum := Ord (ConfNumStr [1]) + (256 * (Ord (ConfNumStr [2])));
  452.  
  453.   Inc (Conferences);
  454.   New (NewConf);
  455.   Anchor := ConfList; { Start at the top of the list. }
  456.  
  457.   IF ConfList = NIL THEN
  458.   BEGIN
  459.     ConfList := NewConf;
  460.     ConfList^.Num := ConfNum;
  461.     ConfList^.Name := ConfName;
  462.     ConfList^.Next := NIL;
  463.   END
  464.   ELSE { Check to see if it comes before the first item in the list }
  465.     IF ConfNum < Anchor^.Num THEN
  466.     BEGIN
  467.       NewConf^.Next := ConfList; { Make the Anchor first come after Next }
  468.       ConfList := NewConf; { This is our new ConfList of the list }
  469.       ConfList^.Num := ConfNum; { and insert our data value(s). }
  470.       ConfList^.Name := ConfName;
  471.     END
  472.   ELSE
  473.   BEGIN
  474.  
  475.     { Here we need to go through the list, but always looking one step
  476.     ahead of where we are, so we can maintain the links. The method
  477.     we'll use here is: looking at Anchor^.Next^.Num
  478.  
  479.     A way to explain that in English is "what is the data pointed to by
  480.     Pointer Next, in the Record pointed to by Pointer Anchor." You may
  481.     need to run that through your List a few times before it clicks, but
  482.     hearing it in English might make it a bit easier for some people to
  483.     understand. }
  484.  
  485.     WHILE (Anchor^.Next <> NIL) AND (ConfNum >= Anchor^.Next^.Num) DO
  486.       Anchor := Anchor^.Next;
  487.  
  488.     IF ConfNum = Anchor^.Num THEN {This clause prevents duplicate numbers}
  489.     BEGIN
  490.       Dispose (NewConf);
  491.       Dec (Conferences);
  492.     END
  493.     ELSE
  494.     BEGIN
  495.       NewConf^.Num := ConfNum;
  496.       NewConf^.Name := ConfName;
  497.       NewConf^.Next := Anchor^.Next;
  498.       Anchor^.Next := NewConf;
  499.     END;
  500.   END;
  501. END;
  502.  
  503. PROCEDURE AddMsgToList (CONST ConfNumStr: STRING; BlockNum: LONGINT);
  504. (* Routine from SWAG *)
  505. { This Procedure will search through an ordered linked list,
  506. find out where the data belongs, and insert it into the list. }
  507.  
  508. VAR
  509.   Anchor, { Where we are in the list }
  510.   NewMsg: MsgRec; { This is what we insert our data into. }
  511.   ConfNum: WORD;
  512.  
  513. BEGIN
  514.   ConfNum := Ord (ConfNumStr [1]) + (256 * (Ord (ConfNumStr [2])));
  515.  
  516.   New (NewMsg);
  517.   Anchor := MsgList; { Start at the top of the list. }
  518.  
  519.   IF MsgList = NIL THEN
  520.   BEGIN
  521.     MsgList := NewMsg;
  522.     MsgList^.Conf := ConfNum;
  523.     MsgList^.Block := BlockNum;
  524.     MsgList^.Next := NIL;
  525.   END
  526.   ELSE { Check to see if it comes before the first item in the list }
  527.     IF ConfNum < Anchor^.Conf THEN
  528.     BEGIN
  529.       NewMsg^.Next := MsgList; { Make the Anchor first come after Next }
  530.       MsgList := NewMsg; { This is our new MsgList of the list }
  531.       MsgList^.Conf := ConfNum; { and insert our data value(s). }
  532.       MsgList^.Block := BlockNum;
  533.     END
  534.   ELSE
  535.   BEGIN
  536.  
  537.     { Here we need to go through the list, but always looking one step
  538.     ahead of where we are, so we can maintain the links. The method
  539.     we'll use here is: looking at Anchor^.Next^.Conf
  540.  
  541.     A way to explain that in English is "what is the data pointed to by
  542.     Pointer Next, in the Record pointed to by Pointer Anchor." You may
  543.     need to run that through your List a few times before it clicks, but
  544.     hearing it in English might make it a bit easier for some people to
  545.     understand. }
  546.  
  547.     WHILE (Anchor^.Next <> NIL) AND (ConfNum >= Anchor^.Next^.Conf) DO
  548.       Anchor := Anchor^.Next;
  549.  
  550.     NewMsg^.Conf := ConfNum;
  551.     NewMsg^.Block := BlockNum;
  552.     NewMsg^.Next := Anchor^.Next;
  553.     Anchor^.Next := NewMsg;
  554.   END;
  555. END;
  556.  
  557. PROCEDURE Verify (CONST control, variable: STRING; OFFSET: BYTE);
  558. BEGIN
  559.   IF (Copy (control, OFFSET, Length (variable)) <> variable) THEN
  560.     Halt (4);
  561. END;
  562.  
  563. FUNCTION AddToArray (VAR Message: MsgArray; OFFSET: WORD; Line: STRING): WORD;
  564. VAR
  565.   index: WORD;
  566. BEGIN
  567.   IF (OFFSET > 128) THEN { remove trailing whitespace }
  568.     Line := RTrim (Line);
  569.   IF (Length (Line) > 0) THEN BEGIN
  570.     FOR index := (OFFSET + 1) TO (OFFSET + Length (Line)) DO BEGIN
  571.       IF (index <= MaxBytes) THEN
  572.         Message [index] := Line [index - OFFSET];
  573.     END
  574.   END
  575.   ELSE index := OFFSET;
  576.   IF (OFFSET >= 128) AND (index < MaxBytes) THEN BEGIN
  577.     Inc (index);
  578.     Message [index] := #227;
  579.   END;
  580.   AddToArray := index;
  581. END;
  582.  
  583. FUNCTION FigureMSGsize (bytes: WORD; VAR chunks: WORD): STRING;
  584. VAR
  585.   MsgChunks: STRING [6];
  586. BEGIN
  587.   chunks := (bytes DIV 128);
  588.   IF ((bytes MOD 128) <> 0) THEN Inc (chunks);
  589.   Str (chunks, MsgChunks);
  590.   MsgChunks := RPad (MsgChunks, 6, #32);
  591.   FigureMSGsize := MsgChunks;
  592. END;
  593.  
  594. PROCEDURE InitConfig (VAR Compressor: PATHSTR);
  595. VAR
  596.   epath: PATHSTR;
  597.   edir : DIRSTR;
  598.   ename: NAMESTR;
  599.   eext : EXTSTR;
  600.   CfgFile: TEXT;
  601.   CfgLine,
  602.   CfgVar, CfgVal: STRING [80];
  603.   equalPos: BYTE;
  604.  
  605. BEGIN
  606.   FSplit (FExpand (ParamStr (0)), edir, ename, eext); { break up path into components }
  607.   epath := edir + ename + '.cfg';
  608.  
  609.   Compressor := 'pkzip -# -m';
  610.   UserName := 'USER NAME';
  611.   BBSID := '';
  612.  
  613.   IF IsFile (epath) THEN
  614.   BEGIN
  615.     Assign (CfgFile, epath);
  616.     Reset (CfgFile); CheckIO;
  617.     WHILE NOT EoF (CfgFile) DO BEGIN { find vars }
  618.       ReadLn (CfgFile, CfgLine);
  619.       equalPos := Pos ('=', CfgLine);
  620.       IF (equalPos > 1) THEN BEGIN
  621.  
  622.         CfgVar := Trim (UpStr (Copy (CfgLine, 1, equalPos - 1)));
  623.         CfgVal := Trim (Copy (CfgLine, equalPos + 1, Length (CfgLine) - equalPos));
  624.  
  625.         IF (CfgVar = 'COMPRESSOR') THEN
  626.           Compressor := CfgVal
  627.  
  628.         ELSE IF (CfgVar = 'USERNAME') THEN
  629.           UserName := Copy (CfgVal, 1, 25)
  630.  
  631.         ELSE IF (CfgVar = 'BBSID') THEN
  632.           BBSID := Copy (CfgVal, 1, 8)
  633.  
  634.       END;
  635.     END; { loop back to read another line }
  636.     Close (CfgFile);
  637.   END;
  638. END;
  639.  
  640. FUNCTION GetDateTime: STRING;
  641. VAR
  642.   Y, m, D, dow,
  643.   h, i, s, s100: WORD;
  644.   Ys: STRING [4];
  645. BEGIN
  646.   GetDate (Y, m, D, dow);
  647.   GetTime (h, i, s, s100);
  648.   Str (Y, Ys);
  649.   GetDateTime := LeadingZero (M) + '-' +
  650.   LeadingZero (D) + '-' +
  651.              (Ys) + ',' +
  652.   LeadingZero (H) + ':' +
  653.   LeadingZero (I) + ':' +
  654.   LeadingZero (S)
  655. END;
  656.  
  657. PROCEDURE GetBBSID;
  658. BEGIN
  659.   BBSID := Trim (BBSID);
  660.   IF BBSID = '' THEN BEGIN
  661.     BBSID := Copy (UpStr (Trim (BBSname)), 1, 8);
  662.     IF Pos (#32, BBSID) <> 0 THEN
  663.       BBSID := Copy (BBSID, 1, Pos (#32, BBSID) - 1);
  664.     IF BBSID = '' THEN BBSID := 'BBSID';
  665.   END;
  666.   IF BBSname = '' THEN BBSname := 'BBS name';
  667.   IF Length (BBSID) > 8 THEN BBSID := Trim (Copy (BBSID,1,8));
  668. END;
  669.  
  670. PROCEDURE WriteControlDAT (CONST CONname: STRING);
  671. VAR
  672.   link: ConfRec;
  673.   cDat: TEXT;
  674. BEGIN
  675.   GetBBSID;
  676.   Assign (cDat, CONname);
  677.   Rewrite (cDat);
  678.   WriteLn (cDat, BBSname);
  679.   WriteLn (cDat, 'City, ST');
  680.   WriteLn (cDat, '000-000-0000');
  681.   WriteLn (cDat, 'Your Sysop, Sysop');
  682.   WriteLn (cDat, '00000,', BBSID);
  683.   WriteLn (cDat, GetDateTime); {in the format: 10-15-1995,06:44:36}
  684.   WriteLn (cDat, UserName);
  685.   WriteLn (cDat);
  686.   WriteLn (cDat, '0');
  687.   WriteLn (cDat, '0');
  688.   WriteLn (cDat, Conferences - 1);
  689.   WHILE ConfList <> NIL DO BEGIN
  690.     WITH ConfList^ DO BEGIN
  691.       WriteLn (cDat, Num);
  692.       WriteLn (cDat, Name);
  693.     END;
  694.     link := ConfList;
  695.     ConfList := ConfList^.next;
  696.     Dispose (link);
  697.   END;
  698.   Close (cDat);
  699. END;
  700.  
  701. PROCEDURE WriteNDXfiles;
  702. TYPE
  703.   bsingle  = ARRAY [0..4] OF BYTE;
  704. VAR
  705.   link: MsgRec;
  706.   NDXfile: FILE;
  707.   NDXname: STRING [12];
  708.   LastConf: LONGINT;
  709.  
  710.   MSbinary  : bSingle;
  711.   realTemp  : REAL;
  712.  
  713.   { converts TP real to Microsoft 4 bytes single ... }
  714.   PROCEDURE real_to_msb (preal : REAL; VAR MSbinary : bsingle);
  715.   VAR
  716.     realTemp : ARRAY [0 .. 5] OF BYTE ABSOLUTE preal;
  717.   BEGIN
  718.     MSbinary [3] := realTemp [0];
  719.     Move (realTemp [3], MSbinary [0], 3);
  720.   END; { procedure real_to_msb }
  721.  
  722. BEGIN
  723.   LastConf := -1;
  724.  
  725.   WHILE MsgList <> NIL DO BEGIN
  726.     WITH MsgList^ DO BEGIN
  727.  
  728.       IF (Conf <> LastConf) THEN BEGIN
  729.         IF (LastConf <> -1) THEN
  730.           Close (NDXfile); CheckIO;
  731.         LastConf := Conf;
  732.         Str (Conf, NDXname);
  733.         NDXname := LPad (NDXname, 3, '0') + '.NDX';
  734.         Assign (NDXfile, NDXname);
  735.         Rewrite (NDXfile, 1); CheckIO;
  736.       END;
  737.  
  738.       realTemp := Block; { make a REAL }
  739.       REAL_TO_MSB (realTemp, MSbinary); { convert to MSB format }
  740.       MSbinary [4] := Conf MOD 256; { put in a dummy conference number }
  741.       BlockWrite (NDXfile, MSbinary, SizeOf (MSbinary)); { store it }
  742.        CheckIO;
  743.  
  744.     END;
  745.     link := MsgList;
  746.     MsgList := MsgList^.next;
  747.     Dispose (link);
  748.   END;
  749.   IF (LastConf <> - 1) THEN
  750.     Close (NDXfile); CheckIO;
  751.  
  752. END;
  753.  
  754. FUNCTION CompressDAT (CONST QWKfile: STRING; CONST Compressor: PATHSTR): BOOLEAN;
  755. VAR
  756.   X, Y, newX: BYTE;
  757. BEGIN
  758.   IF NOT IsFile (CONname) THEN
  759.     WriteControlDAT (CONname);
  760.   WriteNDXfiles;
  761.  
  762.   X := WhereX;
  763.   Y := WhereY;
  764.   Write ('> ', Compressor);
  765.   newX := WhereX;
  766.   DosError := HeapMan. Execute (GetEnv ('COMSPEC'), ' /c ' + compressor + ' ' + QWKfile+ ' *.* >NUL');
  767.   IF DosError <> 0 THEN Halt (5);
  768.   IF (Y = WhereY) AND (WhereX >= newX) THEN
  769.   BEGIN {If we haven't moved to a new line... }
  770.     GotoXY (X, Y); {return to where we were at start of procedure}
  771.     ClrEol;
  772.   END;
  773.  
  774.   cursorOff;
  775.   CompressDAT := IsFile (QWKfile)
  776. END;
  777.  
  778. FUNCTION WipeDir: BOOLEAN;
  779. VAR
  780.   CurrDir: PATHSTR;
  781. BEGIN
  782.   GetDir (0, CurrDir);
  783.   IF CurrDir = TXTQ_DIR THEN BEGIN
  784.     EraseAllFiles;
  785.     ChDir (StartDIR); CheckIO;
  786.     RmDir (TXTQ_DIR); CheckIO;
  787.   END;
  788.   WipeDir := (NOT IsDir (TXTQ_DIR))
  789. END;
  790.  
  791. PROCEDURE Cleanup;
  792. BEGIN
  793.   IF NOT WipeDir THEN BEGIN
  794.     WriteLn;
  795.     WriteLn ('*** ABNORMAL PROGRAM TERMINATION, WORK DIRECTORY STILL EXISTS! ***');
  796.     WriteLn;
  797.   END;
  798. END;
  799.  
  800. BEGIN
  801.   GetDir (0, StartDIR);
  802.   IF StartDir [Length (StartDir)] <> '\'
  803.     THEN TXTQ_DIR := '\'
  804.     ELSE TXTQ_DIR := '';
  805.   TXTQ_DIR := StartDIR + TXTQ_DIR + 'TXTQ_DIR.!!!';
  806. END.
  807.